home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
JCSM Shareware Collection 1993 November
/
JCSM Shareware Collection - 1993-11.iso
/
cl720
/
qbnws31j.lzh
/
TABLDEMO.BAS
< prev
next >
Wrap
BASIC Source File
|
1993-07-23
|
21KB
|
429 lines
'*********************************************************************
'* *
'* PROGRAMNAME : TABLDEMO.BAS *
'* *
'* DESCRIPTION : this program shows you how to declare a *
'* table, how to write it onto the screen, *
'* how to select an item and how to reenter *
'* the table. *
'* *
'* REMARKS : names of constants in include modules are *
'* in dutch language foreign users may alter *
'* names as desired *
'* *
'* REV DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB-NEWS *
'* *
'*********************************************************************
DEFINT A-Z
COMMON SHARED TablDefs()
COMMON SHARED TOP, ROW, COL, HGT, WID, SF, SB, BF, BB, PTR, CUR, BTP
'
' subprograms to be called by user
'
DECLARE SUB TABLOPEN (TNR, TOP, ROW, COL, HGT, WID, SF, SB, BF, BB, TY$)
DECLARE SUB TABLSLCT (TNR, Table$(), Entry$)
'
' subprogram to be called by subprogram TABLSLCT
'
DECLARE SUB DRAWBOX (ROW, COL, VRT, HOR, TY$)
DECLARE SUB TABLDISP (TNR, PTR, Table$())
DECLARE SUB TABLLINE (TNR, CUR, Video$)
DECLARE SUB TABLLOAD (TNR)
'
' include modules for keyboard and colors
'
' $INCLUDE: 'VZKEYBRD.BAS'
' $INCLUDE: 'VZCOLORS.BAS'
DIM TablDefs(6, 12)
'---------------------------------------------------------------------
'------- now forget all previous work and look at this coding --------
'------------- first, declare any matrix and fill it up --------------
'------- with anything you want (file, table, directory etc.) --------
'--------------- than just move thru the table and pick --------------
'---------------------------------------------------------------------
CLS
DATA Ford,Chevrolet,Oldsmobile,Cadillac,Chrysler,Pontiac,Edsel
DATA Studebaker,Skoda,Honda,Mazda,Volvo,Volkswagen,Toyota,Peugeot
DATA Washington,Oregon,Idaho,Montana,Wyoming,North Dakota,South Dakota
DATA Nebraska,Minnesota,Wisconsin,Iowa,Illinois,Indiana,Mitchigan,Ohio
DATA Pennsylvania,New York,Maine,California,Nevada,Utah,Colorado
DATA Arizona,New Mexico,Kansas,Missouri,Kentucky,West Virginia
DATA Virginia,Texas,Oklahoma,Arkansas,Louisiana,Tennessee
DATA North Carolina,South Carolina,Mississippi,Alabama,Georgia,Florida
DATA Hawai,Alaska,Vermont,New Hampshire,Massachusetts,Connecticut
DATA Jersey,Maryland,Rhode Island,Delaware
DIM Cars$(15) 'just some cars
FOR X = 1 TO 15 'get their names
READ Cars$(X) 'fill table
NEXT 'done ?
DIM States$(50) 'I did my best to get all of
FOR X = 1 TO 50 'them 51 states, but... oops
READ States$(X) 'I can't figure out which one
NEXT 'is missing. Sorry for that!
DIM YN$(2) 'just another example
YN$(1) = " Yes "
YN$(2) = " No "
TABLOPEN 1, 15, 8, 30, 10, 30, WT, ZW, ZW, WT, "d"
TABLOPEN 2, 50, 4, 10, 16, 25, ZW, WT, WT + HLDR, ZW, "s"
TABLOPEN 3, 2, 19, 70, 4, 9, WT, ZW, ZW + BLNK, WT, "s"
TABLSLCT 1, Cars$(), YourPick$ 'table = CARS ----->>>----+
TABLSLCT 2, States$(), Bingo$ 'table = STATES --->>>--+ |
TABLSLCT 3, YN$(), NowWhat$ 'table = YN ------->>>--|-|-+
' | | |
CLS 'clear screen | | |
FOR X = 1 TO 24 'paint background | | |
PRINT STRING$(80, CHR$(176)); ' | | |
NEXT ' | | |
Text$ = " any key to re-enter table " ' | | |
LOCATE 12, (80 - LEN(Text$)) \ 2, 0 ' | | |
PRINT Text$; ' | | |
X$ = INPUT$(1) 'wait for keyboard | | |
' | | |
TABLSLCT 2, States$(), Bingo$ 'RE-ENTER TABLE ---<<<--+ | |
TABLSLCT 1, Cars$(), YourPick$ 'RE-ENTER TABLE ---<<<----+ |
' |
LOCATE 24, 1 ' |
PRINT SPACE$(80); ; ' |
LOCATE 24, 1 ' |
PRINT " your pick : "; YourPick$; ' |
' |
TABLSLCT 3, YN$(), OK$ 'done, yes anyway -<<<------+
COLOR WT, ZW 'reset white on black
CLS
'page
'
SUB DRAWBOX (ROW, COL, VRT, HOR, TY$)
'*********************************************************************
'* *
'* PROGRAMNAME : DRAWBOX, draws a box on the screen. The *
'* contents of the box will not be destroyed. *
'* *
'* PARAMETERS : ROW = valid row from 1 thr 25 *
'* COL = valid column from 1 thru 80 *
'* VRT = heigth of box (vertical) *
'* HOR = length of box (horizontal) *
'* TY$ = line type, d= double, s = single *
'* where single is the default value *
'* *
'* REMARKS : validation of line/columns/heigth/width *
'* is supposed to be done by the programmer *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
IF UCASE$(TY$) = "D" THEN 'double lines ?
LTOP$ = CHR$(DCTL): RTOP$ = CHR$(DCTR) 'top left/right
LBOT$ = CHR$(DCBL): RBOT$ = CHR$(DCBR) 'bottom left/right
HLIN$ = CHR$(DLHO): VLIN$ = CHR$(DLVE) 'line hor/vert
ELSE 'single line (default)
LTOP$ = CHR$(SCTL): RTOP$ = CHR$(SCTR) 'top left/right
LBOT$ = CHR$(SCBL): RBOT$ = CHR$(SCBR) 'bottom left/right
HLIN$ = CHR$(SLHO): VLIN$ = CHR$(SLVE) 'line hor/vertical
END IF
HORL$ = STRING$(HOR - 2, HLIN$) 'make horizontal line
COLRT = COL + HOR - 1 'calc right column
LOCATE ROW, COL 'top left location
PRINT LTOP$; HORL$; RTOP$; 'diplay top line
LOCATE ROW + VRT - 1, COL 'bottom left location
PRINT LBOT$; HORL$; RBOT$; 'display bottom line
FOR X = ROW + 1 TO ROW + VRT - 2 'fill in the sides
LOCATE X, COL: PRINT VLIN$; 'left side
LOCATE X, COLRT: PRINT VLIN$; 'right side
NEXT 'done ?
END SUB
'page
'
SUB TABLDISP (TNR, PTR, Table$())
'*********************************************************************
'* *
'* PROGRAMNAME : TABLDISP, displays a table *
'* *
'* PARAMETERS : TNR = table number *
'* PTR = record pointer *
'* Table$() = table name *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
TABLLOAD TNR 'get parms
XPTR = PTR 'temp rec pointer
XROW = ROW 'temp line pointer
DO 'display table
LOCATE XROW, COL 'position cursor
PRINT LEFT$(Table$(XPTR), WID); 'display entry
IF LEN(Table$(XPTR)) < WID THEN 'trailing blanks
PRINT SPACE$(WID - LEN(Table$(XPTR)));
END IF
XROW = XROW + 1 'incr display row
XPTR = XPTR + 1 'incr record pointer
LOOP UNTIL XROW - ROW = HGT 'all lines displayed ?
END SUB
'page
'
SUB TABLLINE (TNR, CUR, Video$)
'*********************************************************************
'* *
'* PROGRAMNAME : TABLLINE, displays a line in the table *
'* *
'* PARAMETERS : TNR = table number *
'* CUR = current line in table *
'* Video$ = normal or reversed video *
'* *
'* REMARKS : fore- and background colors from TablDefs *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
TABLLOAD TNR 'get parms
ABSROW = ROW + CUR - 1 'calc absolute display line
LOCATE ABSROW, COL 'position cursor
ThisLine$ = SPACE$(WID) 'init string
FOR ThisChar = 1 TO WID 'read screen
MID$(ThisLine$, ThisChar) = CHR$(SCREEN(ABSROW, COL + ThisChar - 1))
NEXT
IF UCASE$(Video$) = "N" THEN 'normal video ?
COLOR SF, SB 'set screen colors
PRINT ThisLine$; 'display line at ABSROW, COL
ELSE 'reversed video
COLOR BF, BB 'set bar colors
PRINT ThisLine$; 'display line at ABSROW, COL
COLOR SF, SB 'set screen colors
END IF 'done
END SUB
'page
'
SUB TABLLOAD (TNR)
'*********************************************************************
'* *
'* PROGRAMNAME : TABLLOAD, loads parms for a table *
'* CUR + PTR are variables and are passed *
'* as parameters when called *
'* *
'* PARAMETERS : TNR = table number *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
TOP = TablDefs(TNR, 1) 'table top
ROW = TablDefs(TNR, 2) 'display row
COL = TablDefs(TNR, 3) 'display column
HGT = TablDefs(TNR, 4) 'height
WID = TablDefs(TNR, 5) 'width
BTP = TablDefs(TNR, 12) 'box type
SF = TablDefs(TNR, 6) 'screen foreground
SB = TablDefs(TNR, 7) 'screen background
BF = TablDefs(TNR, 8) 'bar foreground
BB = TablDefs(TNR, 9) 'bar background
END SUB
'page
'
SUB TABLOPEN (TNR, TOP, ROW, COL, HGT, WID, SF, SB, BF, BB, TY$)
'*********************************************************************
'* *
'* PROGRAMNAME : TABLOPEN, saves the parameters of a table *
'* for further use. Re-entry is made possible *
'* *
'* PARAMETERS : TNR = tablenumber 1 thru 6 (see TABLDEFS) *
'* TOP = table size *
'* ROW = display row *
'* COL = display column *
'* HGT = table heigth (lines 1-25) *
'* WID = table width (columns 1-80) *
'* SF = screen color foreground *
'* SB = screen color background *
'* BF = bar color foreground *
'* BB = bar color background *
'* TY$ = line type for drawbox *
'* "" = no box, s = single, d = double *
'* *
'* REMARKS : validation of line/columns/heigth/width *
'* is supposed to be done by the programmer *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
IF LEN(TY$) = 0 THEN 'no box wanted
TablDefs(TNR, 12) = 0 'make boxtype 0
ELSE 'box wanted
TablDefs(TNR, 12) = INSTR("SD", UCASE$(TY$)) 'make boxtype 1 or 2
ROW = ROW + 1: COL = COL + 1 'adjust row & column
HGT = HGT - 2: WID = WID - 2 'adjust heigth & width
END IF
TablDefs(TNR, 1) = TOP 'table size
TablDefs(TNR, 2) = ROW 'display row
TablDefs(TNR, 3) = COL 'display column
TablDefs(TNR, 4) = HGT 'table height
TablDefs(TNR, 5) = WID 'table width
TablDefs(TNR, 6) = SF 'screen foreground
TablDefs(TNR, 7) = SB 'screen background
TablDefs(TNR, 8) = BF 'bar foreground
TablDefs(TNR, 9) = BB 'bar background
TablDefs(TNR, 10) = 1 'init record pointer
TablDefs(TNR, 11) = 1 'init current line
END SUB
'page
'
SUB TABLSLCT (TNR, Table$(), Entry$)
'*********************************************************************
'* *
'* PROGRAMNAME : TABLSLCT, select entry from table *
'* *
'* PARAMETERS : TNR = table number *
'* Table$() = table name *
'* Entry$ = selected entry or <ESCAPE> *
'* *
'* REMARKS : validation of line/columns/heigth/width *
'* is supposed to be done by the programmer *
'* *
'* VER DATE HISTORY *
'* 0.0 18JAN92 Bernard Veerman - version for QB NEWS *
'* *
'*********************************************************************
TABLLOAD TNR 'get parms
PTR = TablDefs(TNR, 10) 'copy record pointer
CUR = TablDefs(TNR, 11) 'copy line pointer
COLOR SF, SB 'set colors (for DRAWBOX)
LOCATE , , 0 'hide cursor
IF TOP < HGT THEN HGT = TOP 'safety first
IF BTP > 0 THEN 'box wanted ?
TY$ = MID$("SD", BTP, 1) 'get box type
DRAWBOX ROW - 1, COL - 1, HGT + 2, WID + 2, TY$
END IF
TABLDISP TNR, PTR, Table$() 'display the table
TABLLINE TNR, CUR, "R" 'first display line
DO 'this is the main loop
DO 'wait for a character
C$ = INKEY$ 'read keyboard
LOOP UNTIL C$ <> "" 'anything yet ?
TABLLINE TNR, CUR, "N" 'normal video
SELECT CASE C$ 'what have we got ?
CASE CHR$(Entr) 'enter
Entry$ = Table$(PTR + CUR - 1) 'copy entry from table
CASE CHR$(Escp) 'escape
Entry$ = "<ESCAPE>" 'easy if you're interested
CASE CHR$(Null) + CHR$(CurH) 'cursor home current page
CUR = 1 'goto first line in page
CASE CHR$(Null) + CHR$(CurE) 'cursor end current page
CUR = HGT 'goto last line in page
CASE CHR$(Null) + CHR$(CtlH) 'cursor home first page
CUR = 1 'reset line pointer
PTR = 1 'reset record pointer
TABLDISP TNR, PTR, Table$() 'display first page
CASE CHR$(Null) + CHR$(CtlE) 'cursor end last page
CUR = HGT 'set line pointer
PTR = TOP - HGT + 1 'set record pointer
TABLDISP TNR, PTR, Table$() 'display last page
CASE CHR$(Null) + CHR$(PgUp) 'page up
PTR = PTR - HGT 'decr pagesize
IF PTR < 1 THEN 'past begin of file ?
CUR = 1 'reset line pointer
PTR = 1 'reset record pointer
END IF '
TABLDISP TNR, PTR, Table$() 'display previous page
CASE CHR$(Null) + CHR$(PgDn) 'page down
PTR = PTR + HGT 'incr pagesize
IF PTR > TOP - HGT + 1 THEN 'past end of file ?
CUR = HGT 'set line pointer
PTR = TOP - HGT + 1 'set record pointer
END IF '
TABLDISP TNR, PTR, Table$() 'display next page
CASE CHR$(Null) + CHR$(ArrU) 'arrow up + scroll
CUR = CUR - 1 'decr line pointer
IF CUR < 1 THEN 'out of page bound ?
CUR = 1 'reset line pointer
IF PTR > 1 THEN 'valid record pointer ?
PTR = PTR - 1 'decr record pointer
TABLDISP TNR, PTR, Table$()
END IF
END IF
CASE CHR$(Null) + CHR$(ArrD) 'arrow down + scroll
CUR = CUR + 1 'incr line pointer
IF CUR > HGT THEN 'out of page bound ?
CUR = HGT 'set line pointer
IF TOP - PTR >= HGT THEN 'valid record pointer ?
PTR = PTR + 1 'incr record pointer
TABLDISP TNR, PTR, Table$()
END IF
END IF
END SELECT
TABLLINE TNR, CUR, "R"
LOOP UNTIL C$ = CHR$(Entr) OR C$ = CHR$(Escp)
LOCATE , , 1 'unhide cursor
TablDefs(TNR, 10) = PTR 'save record pointer
TablDefs(TNR, 11) = CUR 'save current line
END SUB
